home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / scrollbar.stk < prev    next >
Encoding:
Text File  |  1996-07-02  |  12.1 KB  |  357 lines
  1. ;;;;
  2. ;;;; Scrollbars bindings and procs
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;; This software is a derivative work of other copyrighted softwares; the
  15. ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  16. ;;;;
  17. ;;;;
  18. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  19. ;;;;    Creation date: 17-May-1993 12:35
  20. ;;;; Last file update:  2-Jul-1996 19:40
  21. ;;;;
  22.  
  23. (let ()
  24.  
  25. (define tk::init-pos    "")
  26. (define tk::init-values '())
  27.  
  28. ;; Standard Motif bindings:
  29.  
  30. (define-binding "Scrollbar" "<Enter>" (|W| x y)
  31.   (when *tk-strict-motif* 
  32.      (set! tk::active-bg (tk-get |W| :activebackground))
  33.      (tk-set! |W| :activebackground (tk-get |W| :background)))
  34.   (|W| 'activate (|W| 'identify x y)))
  35.  
  36. (define-binding "Scrollbar" "<Motion>" (|W| x y)
  37.   (|W| 'activate (|W| 'identify x y)))
  38.  
  39. (define-binding "Scrollbar" "<Leave>" (|W|)
  40.   (if *tk-strict-motif* 
  41.       (tk-set! |W| :activebackground tk::active-bg))
  42.   (|W| 'activate ""))
  43.  
  44. (define-binding "Scrollbar" "<1>" (|W| x y)
  45.   (Tk:scroll-button-down |W| x y))
  46.  
  47. (define-binding "Scrollbar" "<B1-Motion>" (|W| x y)
  48.   (Tk:scroll-drag |W| x y))
  49.  
  50. (define-binding "Scrollbar" "<B1-B2-Motion>" (|W| x y)
  51.   (Tk:scroll-drag |W| x y))
  52.  
  53. (define-binding "Scrollbar" "<ButtonRelease-1>" (|W| x y)
  54.   (Tk:scroll-button-up |W| x y))
  55.  
  56. (define-binding "Scrollbar" "<B1-Leave>" ()
  57.   ;; Prevents <Leave> binding from being invoked.
  58.   'nop)
  59.  
  60. (define-binding "Scrollbar" "<B1-Enter>" ()
  61.   ;; Prevents <Enter> binding from being invoked.
  62.   'nop)
  63.  
  64. (define-binding "Scrollbar" "<2>" (|W| x y)
  65.   (Tk:scroll-button-2-down |W| x y))
  66.  
  67. (define-binding "Scrollbar" "<B1-2>" ()
  68.   ; Do nothing, since button 1 is already down.
  69.   'nop)
  70.  
  71. (define-binding "Scrollbar" "<B2-1>" (|W| x y)
  72.   ; Do nothing, since button 2 is already down.
  73.   'nop)
  74.  
  75. (define-binding "Scrollbar" "<B2-Motion>" (|W| x y)
  76.   (Tk:scroll-drag |W| x y))
  77.  
  78. (define-binding "Scrollbar" "<ButtonRelease-2>" (|W| x y)
  79.   (Tk:scroll-button-up |W| x y))
  80.  
  81. (define-binding "Scrollbar" "<B1-ButtonRelease-2>" ()
  82.   ;Do nothing:  B1 release will handle it.
  83.   'nop)
  84.  
  85. (define-binding "Scrollbar" "<B2-ButtonRelease-1>" ()
  86.   ;Do nothing:  B1 release will handle it.
  87.   'nop)
  88.  
  89. (define-binding "Scrollbar" "<B2-Leave>" ()
  90.   ;; Prevents <Leave> binding from being invoked.
  91.   'nop)
  92.  
  93. (define-binding "Scrollbar" "<B2-Enter>" ()
  94.   ;; Prevents <Enter> binding from being invoked.
  95.   'nop)
  96.  
  97. (define-binding "Scrollbar" "<Control-1>" (|W| x y)
  98.   (Tk:scroll-top-bottom |W| x y))
  99.  
  100. (define-binding "Scrollbar" "<Control-2>" (|W| x y)
  101.   (Tk:scroll-top-bottom |W| x y))
  102.  
  103. (define-binding "Scrollbar" "<Up>"            (|W|) (Tk:scroll-by-units |W| 'v -1))
  104. (define-binding "Scrollbar" "<Down>"          (|W|) (Tk:scroll-by-units |W| 'v +1))
  105. (define-binding "Scrollbar" "<Control-Up>"    (|W|) (Tk:scroll-by-pages |W| 'v -1))
  106. (define-binding "Scrollbar" "<Control-Down>"  (|W|) (Tk:scroll-by-pages |W| 'v +1))
  107. (define-binding "Scrollbar" "<Left>"           (|W|) (Tk:scroll-by-units |W| 'h -1))
  108. (define-binding "Scrollbar" "<Right>"         (|W|) (Tk:scroll-by-units |W| 'h +1))
  109. (define-binding "Scrollbar" "<Control-Left>"  (|W|) (Tk:scroll-by-pages |W| 'h -1))
  110. (define-binding "Scrollbar" "<Control-Right>" (|W|) (Tk:scroll-by-pages |W| 'hd +1))
  111. (define-binding "Scrollbar" "<Prior>"           (|W|) (Tk:scroll-by-pages |W| 'hv -1))
  112. (define-binding "Scrollbar" "<Next>"           (|W|) (Tk:scroll-by-pages |W| 'hv +1))
  113.  
  114. (define-binding "Scrollbar" "<Home>" (|W|)
  115.   (Tk:scroll-to-pos |W| 0))
  116.  
  117. (define-binding "Scrollbar" "<End>" (|W|)
  118.   (Tk:scroll-to-pos |W| 1))
  119.  
  120.  
  121. ;; Tk:scroll-button-down --
  122. ;; This procedure is invoked when a button is pressed in a scrollbar.
  123. ;; It changes the way the scrollbar is displayed and takes actions
  124. ;; depending on where the mouse is.
  125. ;;
  126. ;; w -        The scrollbar widget.
  127. ;; x, y -    Mouse coordinates.
  128.  
  129. (define (Tk:scroll-button-down w x y)
  130.   (let ((element (w 'identify x y)))
  131.     (set! tk::relief (tk-get w :activerelief))
  132.     (tk-set! w :activerelief "sunken")
  133.     (if (equal? element "slider")
  134.     (Tk:scroll-start-drag w x y)
  135.     (Tk:scroll-select w element "initial"))))
  136.  
  137. ;; Tk:scroll-button-up --
  138. ;; This procedure is invoked when a button is released in a scrollbar.
  139. ;; It cancels scans and auto-repeats that were in progress, and restores
  140. ;; the way the active element is displayed.
  141. ;;
  142. ;; w -        The scrollbar widget.
  143. ;; x, y -    Mouse coordinates.
  144.  
  145. (define (Tk:scroll-button-up w x y)
  146.   (Tk:cancel-repeat)
  147.   (tk-set! w :activerelief tk::relief)
  148.   (Tk:scroll-end-drag w x y)
  149.   (w 'activate (w 'identify x y)))
  150.  
  151.  
  152. ;; Tk:scroll-select --
  153. ;; This procedure is invoked when a button is pressed over the scrollbar.
  154. ;; It invokes one of several scrolling actions depending on where in
  155. ;; the scrollbar the button was pressed.
  156. ;;
  157. ;; w -        The scrollbar widget.
  158. ;; element -    The element of the scrollbar that was selected, such
  159. ;;        as "arrow1" or "trough2".  Shouldn't be "slider".
  160. ;; repeat -    Whether and how to auto-repeat the action:  "noRepeat"
  161. ;;        means don't auto-repeat, "initial" means this is the
  162. ;;        first action in an auto-repeat sequence, and "again"
  163. ;;        means this is the second repetition or later.
  164.  
  165. (define (Tk:scroll-select w element repeat)
  166.   (when (winfo 'exists w)
  167.     (let ((cont (lambda ()
  168.           (cond
  169.            ((string=? repeat "again") 
  170.                  (set! tk::after-id
  171.                    (after (tk-get w :repeatinterval)
  172.                       (lambda ()
  173.                     (Tk:scroll-select w 
  174.                               element 
  175.                               "again")))))
  176.            ((string=? repeat "initial")
  177.                  (let ((delay (tk-get w :repeatdelay)))
  178.                (if (> delay 0)
  179.                    (set! tk::after-id 
  180.                      (after delay
  181.                         (lambda ()
  182.                           (Tk:scroll-select w 
  183.                                 element 
  184.                                 "again")))))))))))
  185.       (cond
  186.        ((equal? element "arrow1")  (Tk:scroll-by-units w 'hv -1) (cont))
  187.        ((equal? element "trough1") (Tk:scroll-by-pages w 'hv -1) (cont))
  188.        ((equal? element "trough2") (Tk:scroll-by-pages w 'hv +1) (cont))
  189.        ((equal? element "arrow2")  (Tk:scroll-by-units w 'hv +1) (cont))))))
  190.  
  191.  
  192. ;; Tk:scroll-start-drag --
  193. ;; This procedure is called to initiate a drag of the slider.  It just
  194. ;; remembers the starting position of the mouse and slider.
  195. ;;
  196. ;; w -        The scrollbar widget.
  197. ;; x, y -    The mouse position at the start of the drag operation.
  198.  
  199. (define (Tk:scroll-start-drag w x y)
  200.   (unless (equal? (tk-get w :command) "")
  201.      (set! tk::press-x x)
  202.      (set! tk::press-y y)
  203.      (set! tk::init-values (w 'get))
  204.      (let ((iv0 (car tk::init-values)))
  205.        (if (= (length tk::init-values) 2)
  206.        (set! tk::init-pos iv0)
  207.        (if (= iv0 0)
  208.            (set! tk::init-pos 0.0)
  209.            (set! tk::init-pos (/ (caddr tk::init-values) 
  210.                      (car tk::init-values))))))))
  211.  
  212. ;; Tk:scroll-drag --
  213. ;; This procedure is called for each mouse motion even when the slider
  214. ;; is being dragged.  It notifies the associated widget if we're not
  215. ;; jump scrolling, and it just updates the scrollbar if we are jump
  216. ;; scrolling.
  217. ;;
  218. ;; w -        The scrollbar widget.
  219. ;; x, y -    The current mouse position.
  220.  
  221. (define (Tk:scroll-drag w x y)
  222.   (unless (equal? tk::init-pos "")
  223.      (let ((delta (w 'delta (- x tk::press-x) (- y tk::press-y))))
  224.        (if (tk-get w :jump)
  225.          (if (equal? (length tk::init-values) 2)
  226.          (w 'set (+ (car  tk::init-values) delta)
  227.                  (+ (cadr tk::init-values) delta))
  228.          (let ((delta (floor (* delta (car tk::init-values)))))
  229.            (w 'set (car  tk::init-values)
  230.                      (cadr tk::init-values)
  231.                (+ (caddr tk::init-values)  delta)
  232.                (+ (cadddr tk::init-values) delta))))
  233.          (Tk:scroll-to-pos w (+ tk::init-pos delta))))))
  234.  
  235. ;; Tk:scroll-end-drag --
  236. ;; This procedure is called to end an interactive drag of the slider.
  237. ;; It scrolls the window if we're in jump mode, otherwise it does nothing.
  238. ;;
  239. ;; w -        The scrollbar widget.
  240. ;; x, y -    The mouse position at the end of the drag operation.
  241.  
  242. (define  (Tk:scroll-end-drag w x y)
  243.   (unless (equal? tk::init-pos "")
  244.      (if (tk-get w :jump)
  245.      (let ((delta (w 'delta (- x tk::press-x) (- y tk::press-y))))
  246.        (Tk:scroll-to-pos w (+ tk::init-pos delta))))
  247.      (set! Tk::init-pos "")))
  248.  
  249.  
  250. ;; Tk:scroll-by-units --
  251. ;; This procedure tells the scrollbar's associated widget to scroll up
  252. ;; or down by a given number of units.  It notifies the associated widget
  253. ;; in different ways for old and new command syntaxes.
  254. ;;
  255. ;; w -        The scrollbar widget.
  256. ;; orient -    Which kinds of scrollbars this applies to:  "h" for
  257. ;;        horizontal, "v" for vertical, "hv" for both.
  258. ;; amount -    How many units to scroll:  typically 1 or -1.
  259.  
  260. (define (Tk:scroll-by-units w orient amount)
  261.   (let ((cmd     (tk-get w :command))
  262.     (worient (tk-get w :orient)))
  263.     (unless (equal? cmd "")
  264.        (when (or (eq? orient 'hv) 
  265.          (and (eq? orient 'h) (string=? worient "horizontal"))
  266.          (and (eq? orient 'v) (string=? worient "vertical")))
  267.        (let ((info (w 'get)))
  268.          (if (= (length info) 2)
  269.          (cmd 'scroll amount 'units)
  270.          (cmd (+ (caddr info) amount))))))))
  271.  
  272. ;; Tk:scroll-by-pages --
  273. ;; This procedure tells the scrollbar's associated widget to scroll up
  274. ;; or down by a given number of screenfuls.  It notifies the associated
  275. ;; widget in different ways for old and new command syntaxes.
  276. ;;
  277. ;; Arguments:
  278. ;; w -        The scrollbar widget.
  279. ;; orient -    Which kinds of scrollbars this applies to:  "h" for
  280. ;;        horizontal, "v" for vertical, "hv" for both.
  281. ;; amount -    How many screens to scroll:  typically 1 or -1.
  282.  
  283. (define (Tk:scroll-by-pages w orient amount)
  284.   (let ((cmd     (tk-get w :command))
  285.     (worient (tk-get w :orient)))
  286.     (unless (equal? cmd "")
  287.        (when (or (eq? orient 'hv) 
  288.          (and (eq? orient 'h) (string=? worient "horizontal"))
  289.          (and (eq? orient 'v) (string=? worient "vertical")))
  290.        (let ((info (w 'get)))
  291.          (if (= (length info) 2)
  292.          (cmd 'scroll amount 'pages)
  293.          (cmd (+ (caddr info) (* (cadr info) amount) -1))))))))
  294.  
  295. ;; Tk:scroll-ToPos --
  296. ;; This procedure tells the scrollbar's associated widget to scroll to
  297. ;; a particular location, given by a fraction between 0 and 1.  It notifies
  298. ;; the associated widget in different ways for old and new command syntaxes.
  299. ;;
  300. ;; Arguments:
  301. ;; w -        The scrollbar widget.
  302. ;; pos -        A fraction between 0 and 1 indicating a desired position
  303. ;;        in the document.
  304.  
  305. (define (Tk:scroll-to-pos w pos)
  306.   (let ((cmd (tk-get w :command)))
  307.     (unless (equal? cmd "")
  308.     (let ((info (w 'get)))
  309.       (if (= (length info) 2)
  310.           (cmd 'moveto pos)
  311.           (cmd (floor (* (car info) pos))))))))
  312.  
  313. ;; Tk:scroll-top-bottom
  314. ;; Scroll to the top or bottom of the document, depending on the mouse
  315. ;; position.
  316. ;;
  317. ;; w -        The scrollbar widget.
  318. ;; x, y -    Mouse coordinates within the widget.
  319.  
  320. (define (Tk:scroll-top-bottom w x y)
  321.   (let ((element (w 'identify x y)))
  322.     (cond
  323.        ((member element '("arrow1" "trough1")) (Tk:scroll-to-pos w 0))
  324.        ((member element '("arrow2" "trough2")) (Tk:scroll-to-pos w 1)))
  325.  
  326.     ;; Set tk::relief, since it's needed by Tk:scroll-button-up.
  327.     (set! tk::relief (tk-get w :activerelief))))
  328.  
  329.  
  330. ;; Tk:scroll-button-2-down
  331. ;; This procedure is invoked when button 2 is pressed over a scrollbar.
  332. ;; If the button is over the trough or slider, it sets the scrollbar to
  333. ;; the mouse position and starts a slider drag.  Otherwise it just
  334. ;; behaves the same as button 1.
  335. ;;
  336. ;; Arguments:
  337. ;; w -        The scrollbar widget.
  338. ;; x, y -    Mouse coordinates within the widget.
  339.  
  340. (define (Tk:scroll-button-2-down w x y)
  341.   (let ((element (w 'identify x y)))
  342.     (if (or (equal? element "arrow1") (equal? element "arrow2"))
  343.     (Tk:scroll-button-down w x y)
  344.     (begin
  345.        (Tk:scroll-to-pos w (w 'fraction x y))
  346.        (set! tk::relief (tk-get w :activerelief))
  347.  
  348.        ; Need the "update idletasks" below so that the widget calls us
  349.        ; back to reset the actual scrollbar position before we start the
  350.        ; slider drag.
  351.        (update 'idletasks)
  352.        (tk-set! w :activerelief "sunken")
  353.        (w 'activate 'slider)
  354.        (Tk:scroll-start-drag w x y)))))
  355.  
  356. )
  357.